home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / oop55.zip / FORMS.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-02  |  11KB  |  571 lines
  1.  
  2. { Turbo Forms }
  3. { Copyright (c) 1989 by Borland International, Inc. }
  4.  
  5. unit Forms;
  6. { Turbo Pascal 5.5 object-oriented example.
  7.   This unit defines field- and form-editing object types.
  8.   Refer to OOPDEMOS.DOC for an overview of this unit.
  9. }
  10.  
  11. {$S-}
  12.  
  13. interface
  14.  
  15. uses Objects;
  16.  
  17. const
  18.  
  19.   CSkip  = ^@;
  20.   CHome  = ^A;
  21.   CRight = ^D;
  22.   CPrev  = ^E;
  23.   CEnd   = ^F;
  24.   CDel   = ^G;
  25.   CBack  = ^H;
  26.   CSave  = ^J;
  27.   CEnter = ^M;
  28.   CUndo  = ^R;
  29.   CLeft  = ^S;
  30.   CIns   = ^V;
  31.   CNext  = ^X;
  32.   CClear = ^Y;
  33.   CEsc   = ^[;
  34.  
  35. type
  36.  
  37.   FStringPtr = ^FString;
  38.   FString = string[79];
  39.  
  40.   FieldPtr = ^Field;
  41.   Field = object(Node)
  42.     X, Y, Size: Integer;
  43.     Title: FStringPtr;
  44.     Value: Pointer;
  45.     Extra: record end;
  46.     constructor Init(PX, PY, PSize: Integer; PTitle: FString);
  47.     constructor Load(var S: Stream);
  48.     destructor Done; virtual;
  49.     procedure Clear; virtual;
  50.     function Edit: Char; virtual;
  51.     procedure Show; virtual;
  52.     procedure Store(var S: Stream);
  53.   end;
  54.  
  55.   FTextPtr = ^FText;
  56.   FText = object(Field)
  57.     Len: Integer;
  58.     constructor Init(PX, PY, PSize: Integer; PTitle: FString;
  59.       PLen: Integer);
  60.     function Edit: Char; virtual;
  61.     procedure GetStr(var S: FString); virtual;
  62.     function PutStr(var S: FString): Boolean; virtual;
  63.     procedure Show; virtual;
  64.   end;
  65.  
  66.   FStrPtr = ^FStr;
  67.   FStr = object(FText)
  68.     constructor Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
  69.     procedure GetStr(var S: FString); virtual;
  70.     function PutStr(var S: FString): Boolean; virtual;
  71.   end;
  72.  
  73.   FNumPtr = ^FNum;
  74.   FNum = object(FText)
  75.     procedure Show; virtual;
  76.   end;
  77.  
  78.   FIntPtr = ^FInt;
  79.   FInt = object(FNum)
  80.     Min, Max: Longint;
  81.     constructor Init(PX, PY: Integer; PTitle: FString;
  82.       PMin, PMax: Longint);
  83.     procedure GetStr(var S: FString); virtual;
  84.     function PutStr(var S: FString): Boolean; virtual;
  85.   end;
  86.  
  87.   FZipPtr = ^FZip;
  88.   FZip = object(FInt)
  89.     constructor Init(PX, PY: Integer; PTitle: FString);
  90.     procedure GetStr(var S: FString); virtual;
  91.     function PutStr(var S: FString): Boolean; virtual;
  92.   end;
  93.  
  94.   FRealPtr = ^FReal;
  95.   FReal = object(FNum)
  96.     Decimals: Integer;
  97.     constructor Init(PX, PY: Integer; PTitle: FString;
  98.       PLen, PDecimals: Integer);
  99.     procedure GetStr(var S: FString); virtual;
  100.     function PutStr(var S: FString): Boolean; virtual;
  101.   end;
  102.  
  103.   FormPtr = ^Form;
  104.   Form = object(Base)
  105.     X1, Y1, X2, Y2, Size: Integer;
  106.     Fields: List;
  107.     constructor Init(PX1, PY1, PX2, PY2: Integer);
  108.     constructor Load(var S: Stream);
  109.     destructor Done; virtual;
  110.     function Edit: Char;
  111.     procedure Show(Erase: Boolean);
  112.     procedure Add(P: FieldPtr);
  113.     procedure Clear;
  114.     procedure Get(var FormBuf);
  115.     procedure Put(var FormBuf);
  116.     procedure Store(var S: Stream);
  117.   end;
  118.  
  119.   FStream = object(BufStream)
  120.     procedure RegisterTypes; virtual;
  121.   end;
  122.  
  123.   ColorIndex = (BackColor, ForeColor, TitleColor, ValueColor);
  124.  
  125. procedure Beep;
  126. procedure Color(C: ColorIndex);
  127. function ReadChar: Char;
  128.  
  129. implementation
  130.  
  131. uses Crt;
  132.  
  133. type
  134.   Bytes = array[0..32767] of Byte;
  135.  
  136. { Field }
  137.  
  138. constructor Field.Init(PX, PY, PSize: Integer; PTitle: FString);
  139. begin
  140.   X := PX;
  141.   Y := PY;
  142.   Size := PSize;
  143.   GetMem(Title, Length(PTitle) + 1);
  144.   Title^ := PTitle;
  145.   GetMem(Value, Size);
  146. end;
  147.  
  148. constructor Field.Load(var S: Stream);
  149. var
  150.   L: Byte;
  151. begin
  152.   S.Read(X, SizeOf(Integer) * 3);
  153.   S.Read(L, SizeOf(Byte));
  154.   GetMem(Title, L + 1);
  155.   Title^[0] := Chr(L);
  156.   S.Read(Title^[1], L);
  157.   GetMem(Value, Size);
  158.   S.Read(Extra, SizeOf(Self) - SizeOf(Field));
  159. end;
  160.  
  161. destructor Field.Done;
  162. begin
  163.   FreeMem(Value, Size);
  164.   FreeMem(Title, Length(Title^) + 1);
  165. end;
  166.  
  167. procedure Field.Clear;
  168. begin
  169.   FillChar(Value^, Size, 0);
  170. end;
  171.  
  172. function Field.Edit: Char;
  173. begin
  174.   Abstract;
  175. end;
  176.  
  177. procedure Field.Show;
  178. begin
  179.   Abstract;
  180. end;
  181.  
  182. procedure Field.Store(var S: Stream);
  183. begin
  184.   S.Write(X, SizeOf(Integer) * 3);
  185.   S.Write(Title^, Length(Title^) + 1);
  186.   S.Write(Extra, SizeOf(Self) - SizeOf(Field));
  187. end;
  188.  
  189. { FText }
  190.  
  191. constructor FText.Init(PX, PY, PSize: Integer; PTitle: FString;
  192.   PLen: Integer);
  193. begin
  194.   Field.Init(PX, PY, PSize, PTitle);
  195.   Len := PLen;
  196. end;
  197.  
  198. function FText.Edit: Char;
  199. var
  200.   P: Integer;
  201.   Ch: Char;
  202.   Start, Stop: Boolean;
  203.   S: FString;
  204. begin
  205.   P := 0;
  206.   Start := True;
  207.   Stop := False;
  208.   GetStr(S);
  209.   repeat
  210.     GotoXY(X, Y);
  211.     Color(TitleColor);
  212.     Write(Title^);
  213.     Color(ValueColor);
  214.     Write(S, '': Len - Length(S));
  215.     GotoXY(X + Length(Title^) + P, Y);
  216.     Ch := ReadChar;
  217.     case Ch of
  218.       #32..#255:
  219.         begin
  220.           if Start then S := '';
  221.           if Length(S) < Len then
  222.           begin
  223.             Inc(P);
  224.             Insert(Ch, S, P);
  225.           end;
  226.         end;
  227.       CLeft: if P > 0 then Dec(P);
  228.       CRight: if P < Length(S) then Inc(P) else;
  229.       CHome: P := 0;
  230.       CEnd: P := Length(S);
  231.       CDel: Delete(S, P + 1, 1);
  232.       CBack:
  233.         if P > 0 then
  234.         begin
  235.           Delete(S, P, 1);
  236.           Dec(P);
  237.         end;
  238.       CClear:
  239.         begin
  240.           S := '';
  241.           P := 0;
  242.         end;
  243.       CUndo:
  244.         begin
  245.           GetStr(S);
  246.           P := 0;
  247.         end;
  248.       CEnter, CNext, CPrev, CSave:
  249.         if PutStr(S) then
  250.         begin
  251.           Show;
  252.           Stop := True;
  253.         end else
  254.         begin
  255.           Beep;
  256.           P := 0;
  257.         end;
  258.       CEsc: Stop := True;
  259.     else
  260.       Beep;
  261.     end;
  262.     Start := False;
  263.   until Stop;
  264.   Edit := Ch;
  265. end;
  266.  
  267. procedure FText.GetStr(var S: FString);
  268. begin
  269.   Abstract;
  270. end;
  271.  
  272. function FText.PutStr(var S: FString): Boolean;
  273. begin
  274.   Abstract;
  275. end;
  276.  
  277. procedure FText.Show;
  278. var
  279.   S: FString;
  280. begin
  281.   GetStr(S);
  282.   GotoXY(X, Y);
  283.   Color(TitleColor);
  284.   Write(Title^);
  285.   Color(ValueColor);
  286.   Write(S, '': Len - Length(S));
  287. end;
  288.  
  289. { FStr }
  290.  
  291. constructor FStr.Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
  292. begin
  293.   FText.Init(PX, PY, PLen + 1, PTitle, PLen);
  294. end;
  295.  
  296. procedure FStr.GetStr(var S: FString);
  297. begin
  298.   S := FString(Value^);
  299. end;
  300.  
  301. function FStr.PutStr(var S: FString): Boolean;
  302. begin
  303.   FString(Value^) := S;
  304.   PutStr := True;
  305. end;
  306.  
  307. { FNum }
  308.  
  309. procedure FNum.Show;
  310. var
  311.   S: FString;
  312. begin
  313.   GetStr(S);
  314.   GotoXY(X, Y);
  315.   Color(TitleColor);
  316.   Write(Title^);
  317.   Color(ValueColor);
  318.   Write(S: Len);
  319. end;
  320.  
  321. { FInt }
  322.  
  323. constructor FInt.Init(PX, PY: Integer; PTitle: FString;
  324.   PMin, PMax: Longint);
  325. var
  326.   L: Integer;
  327.   S: string[15];
  328. begin
  329.   Str(PMin, S); L := Length(S);
  330.   Str(PMax, S); if L < Length(S) then L := Length(S);
  331.   FNum.Init(PX, PY, SizeOf(Longint), PTitle, L);
  332.   Min := PMin;
  333.   Max := PMax;
  334. end;
  335.  
  336. procedure FInt.GetStr(var S: FString);
  337. begin
  338.   Str(Longint(Value^), S);
  339. end;
  340.  
  341. function FInt.PutStr(var S: FString): Boolean;
  342. var
  343.   N: Longint;
  344.   E: Integer;
  345. begin
  346.   Val(S, N, E);
  347.   if (E = 0) and (N >= Min) and (N <= Max) then
  348.   begin
  349.     Longint(Value^) := N;
  350.     PutStr := True;
  351.   end else PutStr := False;
  352. end;
  353.  
  354. { FZip }
  355.  
  356. constructor FZip.Init(PX, PY: Integer; PTitle: FString);
  357. begin
  358.   FInt.Init(PX, PY, PTitle, 0, 99999);
  359. end;
  360.  
  361. procedure FZip.GetStr(var S: FString);
  362. begin
  363.   FInt.GetStr(S);
  364.   Insert(Copy('0000', 1, 5 - Length(S)), S, 1);
  365. end;
  366.  
  367. function FZip.PutStr(var S: FString): Boolean;
  368. begin
  369.   PutStr := (Length(S) = 5) and FInt.PutStr(S);
  370. end;
  371.  
  372. { FReal }
  373.  
  374. constructor FReal.Init(PX, PY: Integer; PTitle: FString;
  375.   PLen, PDecimals: Integer);
  376. begin
  377.   FNum.Init(PX, PY, SizeOf(Real), PTitle, PLen);
  378.   Decimals := PDecimals;
  379. end;
  380.  
  381. procedure FReal.GetStr(var S: FString);
  382. begin
  383.   Str(Real(Value^): 0: Decimals, S);
  384. end;
  385.  
  386. function FReal.PutStr(var S: FString): Boolean;
  387. var
  388.   R: Real;
  389.   E: Integer;
  390.   T: FString;
  391. begin
  392.   Val(S, R, E);
  393.   PutStr := False;
  394.   if E = 0 then
  395.   begin
  396.     Str(R: 0: Decimals, T);
  397.     if Length(T) <= Len then
  398.     begin
  399.       Real(Value^) := R;
  400.       PutStr := True;
  401.     end;
  402.   end;
  403. end;
  404.  
  405. { Form }
  406.  
  407. constructor Form.Init(PX1, PY1, PX2, PY2: Integer);
  408. begin
  409.   X1 := PX1;
  410.   Y1 :=